home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / efs-vms.el.z / efs-vms.el
Encoding:
Text File  |  1998-05-21  |  26.2 KB  |  761 lines
  1. ;; -*-Emacs-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;; File:         efs-vms.el
  5. ;; Release:      $efs release: 1.15 $
  6. ;; Version:      #Revision: 1.13 $
  7. ;; RCS:          
  8. ;; Description:  VMS support for efs
  9. ;; Authors:      Andy Norman, Joe Wells, Sandy Rutherford <sandy@itp.ethz.ch>
  10. ;; Modified:     Sun Nov 27 18:44:59 1994 by sandy on gandalf
  11. ;;
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. ;;; This file is part of efs. See efs.el for copyright
  15. ;;; (it's copylefted) and warrranty (there isn't one) information.
  16.  
  17. (provide 'efs-vms)
  18. (require 'efs)
  19.  
  20. (defconst efs-vms-version
  21.   (concat (substring "$efs release: 1.15 $" 14 -2)
  22.       "/"
  23.       (substring "#Revision: 1.13 $" 11 -2)))
  24.  
  25. ;;;; ------------------------------------------------------------
  26. ;;;; VMS support.
  27. ;;;; ------------------------------------------------------------
  28.  
  29. ;;; efs has full support for VMS hosts, including tree dired support.  It
  30. ;;; should be able to automatically recognize any VMS machine. However, if it
  31. ;;; fails to do this, you can use the command efs-add-vms-host.  As well,
  32. ;;; you can set the variable efs-vms-host-regexp in your .emacs file. We
  33. ;;; would be grateful if you would report any failures to automatically
  34. ;;; recognize a VMS host as a bug.
  35. ;;;
  36. ;;; Filename Syntax:
  37. ;;;
  38. ;;; For ease of *implementation*, the user enters the VMS filename syntax in a
  39. ;;; UNIX-y way.  For example:
  40. ;;;  PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1
  41. ;;; would be entered as:
  42. ;;;  /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1
  43. ;;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file:
  44. ;;;  [.CSV.POLICY]RULES.MEM
  45. ;;; you would type:
  46. ;;;  C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM
  47. ;;;
  48. ;;; A legal VMS filename is of the form: FILE.TYPE;##
  49. ;;; where FILE can be up to 39 characters
  50. ;;;       TYPE can be up to 39 characters
  51. ;;;       ## is a version number (an integer between 1 and 32,767)
  52. ;;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $
  53. ;;; $ cannot begin a filename, and - cannot be used as the first or last
  54. ;;; character.
  55. ;;;
  56. ;;; Tips:
  57. ;;; 1. To access the latest version of file under VMS, you use the filename
  58. ;;;    without the ";" and version number. You should always edit the latest
  59. ;;;    version of a file. If you want to edit an earlier version, copy it to a
  60. ;;;    new file first. This has nothing to do with efs, but is simply
  61. ;;;    good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is
  62. ;;;    latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you
  63. ;;;    inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find
  64. ;;;    that VMS will not allow you to save the file because it will refuse to
  65. ;;;    overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and
  66. ;;;    attach the buffer to this file. To get out of this situation, M-x
  67. ;;;    write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to
  68. ;;;    latest version of the file. For this reason, in tree dired "f"
  69. ;;;    (dired-find-file), always loads the file sans version, whereas "v",
  70. ;;;    (dired-view-file), always loads the explicit version number. The
  71. ;;;    reasoning being that it reasonable to view old versions of a file, but
  72. ;;;    not to edit them.
  73. ;;; 2. EMACS has a feature in which it does environment variable substitution
  74. ;;;    in filenames. Therefore, to enter a $ in a filename, you must quote it
  75. ;;;    by typing $$. There is a bug in EMACS, in that it neglects to quote the
  76. ;;;    $'s in the default directory when it writes it in the minibuffer.  You
  77. ;;;    must edit the minibuffer to quote the $'s manually. Hopefully, this bug
  78. ;;;    will be fixed in EMACS 19. If you use Sebastian Kremer's gmhist (V 4.26
  79. ;;;    or newer), you will not have this problem.
  80.  
  81.  
  82. ;; Because some VMS ftp servers convert filenames to lower case
  83. ;; we allow a-z in the filename regexp.
  84.  
  85. (defconst efs-vms-filename-regexp
  86.   "\\([_A-Za-z0-9$][-_A-Za-z0-9$]*\\)?\\.\\([-_A-Za-z0-9$]*\\);[0-9]+")
  87. ;; Regular expression to match for a valid VMS file name in Dired buffer.
  88.  
  89. (defvar efs-vms-month-alist
  90.   '(("JAN" . 1) ("FEB". 2) ("MAR" . 3) ("APR" . 4) ("MAY" . 5) ("JUN" . 6)
  91.     ("JUL" . 7) ("AUG" . 8) ("SEP" . 9) ("OCT" . 10)
  92.     ("NOV" . 11) ("DEC" . 12)))
  93.  
  94. (defvar efs-vms-date-regexp
  95.   (concat
  96.    "\\([0-3]?[0-9]\\)-"
  97.    "\\(JAN\\|FEB\\|MAR\\|APR\\|MAY\\|JUN\\|"
  98.    "JUL\\|AUG\\|SEP\\|OCT\\|NOV\\|DEC\\)-"
  99.    "\\([0-9][0-9][0-9]?[0-9]?\\) \\(\\([0-5][0-9]\\):\\([0-5][0-9]\\)"
  100.    "\\(:[0-5][0-9]\\)?\\)? "))
  101.  
  102.  
  103. ;;; The following two functions are entry points to this file.
  104. ;;; They are defined as efs-autoloads in efs.el
  105.  
  106. (efs-defun efs-fix-path vms (path &optional reverse)
  107.   ;; Convert PATH from UNIX-ish to VMS.
  108.   ;; If REVERSE given then convert from VMS to UNIX-ish.
  109.   (efs-save-match-data
  110.     (if reverse
  111.     (if (string-match
  112.          "^\\([^:]+:\\)?\\(\\[[^]]+\\]\\)?\\([^][]*\\)$" path)
  113.         (let (drive dir file)
  114.           (if (match-beginning 1)
  115.           (setq drive (substring path
  116.                      (match-beginning 1)
  117.                      (match-end 1))))
  118.           (if (match-beginning 2)
  119.           (setq dir
  120.             (substring path (match-beginning 2) (match-end 2))))
  121.           (if (match-beginning 3)
  122.           (setq file
  123.             (substring path (match-beginning 3) (match-end 3))))
  124.           (and dir
  125.            (setq dir (apply (function concat)
  126.                     (mapcar (function
  127.                          (lambda (char)
  128.                            (if (= char ?.)
  129.                            (vector ?/)
  130.                          (vector char))))
  131.                         (substring dir 1 -1)))))
  132.           (concat (and drive
  133.                (concat "/" drive "/"))
  134.               dir (and dir "/")
  135.               file))
  136.       (error "path %s didn't match" path))
  137.       (let (drive dir file)
  138.     (if (string-match "^/[^:/]+:/" path)
  139.         (setq drive (substring path 1 (1- (match-end 0)))
  140.           path (substring path (1- (match-end 0)))))
  141.     (setq dir (file-name-directory path)
  142.           file (efs-internal-file-name-nondirectory path))
  143.     (if dir
  144.         (let ((len (1- (length dir)))
  145.           (n 0))
  146.           (if (<= len 0)
  147.           (setq dir nil)
  148.         (while (<= n len)
  149.           (and (char-equal (aref dir n) ?/)
  150.                (cond
  151.             ((zerop n) (aset dir n ?\[))
  152.             ((= n len) (aset dir n ?\]))
  153.             (t (aset dir n ?.))))
  154.           (setq n (1+ n))))))
  155.     (concat drive dir file)))))
  156.  
  157. ;; It is important that this function barf for directories for which we know
  158. ;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/".
  159. ;; This is because it saves an unnecessary FTP error, or possibly the listing
  160. ;; might succeed, but give erroneous info. This last case is particularly
  161. ;; likely for OS's (like MTS) for which we need to use a wildcard in order
  162. ;; to list a directory.
  163.  
  164. (efs-defun efs-fix-dir-path vms (dir-path)
  165.   ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing.
  166.   ;; Should there be entries for .. -> [-] and . -> [] below. Don't
  167.   ;; think so, because expand-filename should have already short-circuited
  168.   ;; them.
  169.   (cond ((string-equal dir-path "/")
  170.      (error "Cannot get listing for fictitious \"/\" directory."))
  171.     ((string-match "^/[-A-Z0-9_$]+:/$" dir-path)
  172.      (error "Cannot get listing for device."))
  173.     ((efs-fix-path 'vms dir-path))))
  174.   
  175. ;; These parsing functions are as general as possible because the syntax
  176. ;; of ftp listings from VMS hosts is a bit erratic. What saves us is that
  177. ;; the VMS filename syntax is so rigid. If they bomb on a listing in the
  178. ;; standard VMS Multinet format, then this is a bug. If they bomb on a listing
  179. ;; from vms.weird.net, then too bad.
  180.  
  181. (defmacro efs-parse-vms-filename ()
  182.   "Extract the next filename from a VMS dired-like listing."
  183.   (` (if (re-search-forward
  184.       efs-vms-filename-regexp
  185.       nil t)
  186.      (buffer-substring (match-beginning 0) (match-end 0)))))
  187.  
  188. (defun efs-parse-vms-listing ()
  189.   ;; Parse the current buffer which is assumed to be a VMS DIR
  190.   ;; listing (either a short (NLIST) or long listing).
  191.   ;; Assumes that point is at the beginning of the buffer.
  192.   (let ((tbl (efs-make-hashtable))
  193.     file)
  194.     (goto-char (point-min))
  195.     (efs-save-match-data
  196.       (while (setq file (efs-parse-vms-filename))
  197.     (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
  198.         ;; deal with directories
  199.         (efs-put-hash-entry
  200.          (substring file 0 (match-beginning 0)) '(t) tbl)
  201.       (efs-put-hash-entry file '(nil) tbl)
  202.       (if (string-match ";[0-9]+$" file) ; deal with extension
  203.           ;; sans extension
  204.           (efs-put-hash-entry
  205.            (substring file 0 (match-beginning 0)) '(nil) tbl)))
  206.     (forward-line 1))
  207.       ;; Would like to look for a "Total" line, or a "Directory" line to
  208.       ;; make sure that the listing isn't complete garbage before putting
  209.       ;; in "." and "..", but we can't even count on all VAX's giving us
  210.       ;; either of these.
  211.       (efs-put-hash-entry "." '(t) tbl)
  212.       (efs-put-hash-entry ".." '(t) tbl))
  213.     tbl))
  214.  
  215. (efs-defun efs-parse-listing vms
  216.   (host user dir path &optional switches)
  217.   ;; Parse the current buffer which is assumed to be a VMS FTP dir
  218.   ;; format, and return a hashtable as the result. SWITCHES are never used,
  219.   ;; but they must be specified in the argument list for compatibility
  220.   ;; with the unix version of this function.
  221.   ;; HOST = remote host name
  222.   ;; USER = user name
  223.   ;; DIR = directory in as a full remote path
  224.   ;; PATH = directory in full efs path syntax
  225.   ;; SWITCHES = ls switches (not relevant here)
  226.   (goto-char (point-min))
  227.   (efs-save-match-data
  228.     ;; check for a DIR/FULL monstrosity
  229.     (if (search-forward "\nSize:" nil t)
  230.     (progn
  231.       (efs-add-listing-type 'vms:full host user)
  232.       ;; This will cause the buffer to be refilled with an NLIST
  233.       (let ((efs-ls-uncache t))
  234.         (efs-ls path nil (format "Relisting %s"
  235.                      (efs-relativize-filename path))
  236.             t))
  237.       (goto-char (point-min))
  238.       (efs-parse-vms-listing))
  239.       (efs-parse-vms-listing))))
  240.  
  241.  
  242. ;;;; Sorting of listings
  243.  
  244. (efs-defun efs-t-converter vms (&optional regexp reverse)
  245.   (if regexp
  246.       nil
  247.     (goto-char (point-min))
  248.     (efs-save-match-data
  249.       (if (re-search-forward efs-vms-filename-regexp nil t)
  250.       (let (list-start start end list)
  251.         (beginning-of-line)
  252.         (setq list-start (point))
  253.         (while (and (looking-at efs-vms-filename-regexp)
  254.             (progn
  255.               (setq start (point))
  256.               (goto-char (match-end 0))
  257.               (forward-line (if (eolp) 2 1))
  258.               (setq end (point))
  259.               (goto-char (match-end 0))
  260.               (re-search-forward efs-vms-date-regexp nil t)))
  261.           (setq list
  262.             (cons
  263.              (cons
  264.               (nconc
  265.                (list (string-to-int (buffer-substring
  266.                          (match-beginning 3)
  267.                          (match-end 3))) ; year
  268.                  (cdr (assoc
  269.                    (buffer-substring (match-beginning 2)
  270.                              (match-end 2))
  271.                    efs-vms-month-alist)) ; month
  272.                  (string-to-int (buffer-substring
  273.                          (match-beginning 1)
  274.                          (match-end 1)))) ;day
  275.                (if (match-beginning 4)
  276.                (list
  277.                 (string-to-int (buffer-substring
  278.                         (match-beginning 5)
  279.                         (match-end 5))) ; hour
  280.                 (string-to-int (buffer-substring
  281.                         (match-beginning 6)
  282.                         (match-end 6))) ; minute
  283.                 (if (match-beginning 7)
  284.                 (string-to-int (buffer-substring
  285.                         (1+ (match-beginning 7))
  286.                         (match-end 7))) ; seconds
  287.                   0))
  288.              (list 0 0 0)))
  289.               (buffer-substring start end))
  290.              list))
  291.           (goto-char end))
  292.         (if list
  293.         (progn
  294.           (setq list
  295.             (mapcar 'cdr
  296.                 (sort list 'efs-vms-t-converter-sort-pred)))
  297.           (if reverse (setq list (nreverse list)))
  298.           (delete-region list-start (point))
  299.           (apply 'insert list)))
  300.         t)))))
  301.  
  302. (defun efs-vms-t-converter-sort-pred (elt1 elt2)
  303.   (let* ((data1 (car elt1))
  304.      (data2 (car elt2))
  305.      (year1 (car data1))
  306.      (year2 (car data2))
  307.      (month1 (nth 1 data1))
  308.      (month2 (nth 1 data2))
  309.      (day1 (nth 2 data1))
  310.      (day2 (nth 2 data2))
  311.      (hour1 (nth 3 data1))
  312.      (hour2 (nth 3 data2))
  313.      (minute1 (nth 4 data1))
  314.      (minute2 (nth 4 data2)))
  315.     (or (> year1 year2)
  316.     (and (= year1 year2)
  317.          (or (> month1 month2)
  318.          (and (= month1 month2)
  319.               (or (> day1 day2)
  320.               (and (= day1 day2)
  321.                    (or (> hour1 hour2)
  322.                    (and (= hour1 hour2)
  323.                     (or (> minute1 minute2)
  324.                         (and (= minute1 minute2)
  325.                          (or (> (nth 5 data1)
  326.                             (nth 5 data2)))
  327.                          ))))))))))))
  328.  
  329.  
  330. (efs-defun efs-X-converter vms (&optional regexp reverse)
  331.   ;; Sorts by extension
  332.   (if regexp
  333.       nil
  334.     (goto-char (point-min))
  335.     (efs-save-match-data
  336.       (if (re-search-forward efs-vms-filename-regexp nil t)
  337.       (let (list-start start list)
  338.         (beginning-of-line)
  339.         (setq list-start (point))
  340.         (while (looking-at efs-vms-filename-regexp)
  341.           (setq start (point))
  342.           (goto-char (match-end 0))
  343.           (forward-line (if (eolp) 2 1))
  344.           (setq list
  345.             (cons
  346.              (cons (buffer-substring (match-beginning 2)
  347.                          (match-end 2))
  348.                (buffer-substring start (point)))
  349.              list)))
  350.         (setq list
  351.           (mapcar 'cdr
  352.               (sort list
  353.                 (if reverse
  354.                     (function
  355.                      (lambda (x y)
  356.                     (string< (car y) (car x))))
  357.                   (function
  358.                    (lambda (x y)
  359.                      (string< (car x) (car y))))))))
  360.         (delete-region list-start (point))
  361.         (apply 'insert list)
  362.         t)))))
  363.  
  364. ;; This version only deletes file entries which have
  365. ;; explicit version numbers, because that is all VMS allows.
  366.  
  367. (efs-defun efs-delete-file-entry vms (path &optional dir-p)
  368.   (let ((ignore-case (memq 'vms efs-case-insensitive-host-types)))
  369.     (if dir-p
  370.     (let ((path (file-name-as-directory path))
  371.           files)
  372.       (efs-del-hash-entry path efs-files-hashtable ignore-case)
  373.       (setq path (directory-file-name path)
  374.         files (efs-get-hash-entry (file-name-directory path)
  375.                            efs-files-hashtable
  376.                            ignore-case))
  377.       (if files
  378.           (efs-del-hash-entry (efs-get-file-part path)
  379.                        files ignore-case)))
  380.       (efs-save-match-data
  381.     (let ((file (efs-get-file-part path)))
  382.       (if (string-match ";[0-9]+$" file)
  383.           ;; In VMS you can't delete a file without an explicit    
  384.           ;; version number, or wild-card (e.g. FOO;*)
  385.           ;; For now, we give up on wildcards.
  386.           (let ((files (efs-get-hash-entry
  387.                 (file-name-directory path)
  388.                 efs-files-hashtable ignore-case)))
  389.         (if files
  390.             (let ((root (substring file 0
  391.                        (match-beginning 0)))
  392.               (completion-ignore-case ignore-case)
  393.               (len (match-beginning 0)))
  394.               (efs-del-hash-entry file files ignore-case)
  395.               ;; Now we need to check if there are any
  396.               ;; versions left. If not, then delete the
  397.               ;; root entry.
  398.               (or (all-completions
  399.                root files
  400.                (function
  401.                 (lambda (sym)
  402.                   (string-match ";[0-9]+$"
  403.                         (symbol-name sym) len))))
  404.               (efs-del-hash-entry root files
  405.                            ignore-case)))))))))
  406.     (efs-del-from-ls-cache path t ignore-case)))
  407.  
  408. (efs-defun efs-add-file-entry vms (path dir-p size owner
  409.                           &optional modes nlinks mdtm)
  410.   ;; The vms version of this function needs to keep track
  411.   ;; of vms's file versions.
  412.   (let ((ignore-case (memq 'vms efs-case-insensitive-host-types))
  413.     (ent (let ((dir-p (null (null dir-p))))
  414.            (if mdtm
  415.            (list dir-p size owner nil nil mdtm)
  416.          (list dir-p size owner)))))
  417.     (if dir-p
  418.     (let* ((path (directory-file-name path))
  419.            (files (efs-get-hash-entry  (file-name-directory path)
  420.                         efs-files-hashtable
  421.                         ignore-case)))
  422.       (if files
  423.           (efs-put-hash-entry (efs-get-file-part path)
  424.                        ent files ignore-case)))
  425.       (let ((files (efs-get-hash-entry
  426.             (file-name-directory path)
  427.             efs-files-hashtable ignore-case)))
  428.     (if files
  429.         (let ((file (efs-get-file-part path)))
  430.           (efs-save-match-data
  431.         ;; In VMS files must have an extension. If there isn't
  432.         ;; one, it will be added.
  433.         (or (string-match "^[^;]*\\." file)
  434.             (if (string-match ";" file)
  435.             (setq file (concat
  436.                     (substring file 0 (match-beginning 0))
  437.                     ".;"
  438.                     (substring file (match-end 0))))
  439.               (setq file (concat file "."))))
  440.         (if (string-match ";[0-9]+$" file)
  441.             (efs-put-hash-entry
  442.              (substring file 0 (match-beginning 0))
  443.              ent files ignore-case)
  444.           ;; Need to figure out what version of the file
  445.           ;; is being added.
  446.           (let* ((completion-ignore-case ignore-case)
  447.              (len (length file))
  448.              (versions (all-completions
  449.                     file files
  450.                     (function
  451.                      (lambda (sym)
  452.                        (string-match ";[0-9]+$"
  453.                              (symbol-name sym) len)))))
  454.              (N (1+ len))
  455.              (max (apply
  456.                    'max
  457.                    (cons 0 (mapcar
  458.                     (function
  459.                      (lambda (x)
  460.                        (string-to-int (substring x N))))
  461.                     versions)))))
  462.             ;; No need to worry about case here.
  463.             (efs-put-hash-entry
  464.              (concat file ";" (int-to-string (1+ max))) ent files))))
  465.           (efs-put-hash-entry file ent files ignore-case)))))
  466.     (efs-del-from-ls-cache path t ignore-case)))
  467.  
  468. (efs-defun efs-really-file-p vms (file ent)
  469.   ;; Returns whether the hash entry FILE with entry ENT is a real file.
  470.   (or (car ent) ; file-directory-p
  471.       (efs-save-match-data
  472.     (string-match ";" file))))
  473.  
  474. (efs-defun efs-internal-file-name-as-directory vms (name)
  475.   (efs-save-match-data
  476.     (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name)
  477.     (setq name (substring name 0 (match-beginning 0))))
  478.     (let (file-name-handler-alist)
  479.       (file-name-as-directory name))))
  480.  
  481. (efs-defun efs-remote-directory-file-name vms (dir)
  482.   ;; Returns the VMS filename in unix directory syntax for directory DIR.
  483.   ;; This is something like /FM/SANDY/FOOBAR.DIR;1
  484.   (efs-save-match-data
  485.     (setq dir (directory-file-name dir))
  486.     (concat dir
  487.         (if (string-match "[a-z]" (nth 2 (efs-ftp-path dir)))
  488.         ".dir;1"
  489.           ".DIR;1"))))
  490.  
  491. (efs-defun efs-allow-child-lookup vms (host user dir file)
  492.   ;; Returns t if FILE in directory DIR could possibly be a subdir
  493.   ;; according to its file-name syntax, and therefore a child listing should
  494.   ;; be attempted.
  495.  
  496.   ;; Subdirs in VMS can't have an extension (other than .DIR, which we
  497.   ;; have truncated).
  498.   (not (or (string-match "\\." file)
  499.        (and (boundp 'dired-local-variables-file)
  500.         (stringp dired-local-variables-file)
  501.         (string-equal dired-local-variables-file file)))))
  502.  
  503. ;;; Tree dired support:
  504.  
  505. ;; For this code I have borrowed liberally from Sebastian Kremer's
  506. ;; dired-vms.el
  507.  
  508.  
  509. ;; These regexps must be anchored to beginning of line.
  510. ;; Beware that the ftpd may put the device in front of the filename.
  511.  
  512. (defconst efs-dired-vms-re-exe
  513.   "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]")
  514.  
  515. (or (assq 'vms efs-dired-re-exe-alist)
  516.     (setq efs-dired-re-exe-alist
  517.       (cons (cons 'vms  efs-dired-vms-re-exe)
  518.         efs-dired-re-exe-alist)))
  519.  
  520. (defconst efs-dired-vms-re-dir
  521.   "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]")
  522.  
  523. (or (assq 'vms efs-dired-re-dir-alist)
  524.     (setq efs-dired-re-dir-alist
  525.       (cons (cons 'vms  efs-dired-vms-re-dir)
  526.         efs-dired-re-dir-alist)))
  527.  
  528. (efs-defun efs-dired-insert-headerline vms (dir)
  529.   ;; VMS inserts a headerline. I would prefer the headerline
  530.   ;; to be in efs format. This version tries to
  531.   ;; be careful, because we can't count on a headerline
  532.   ;; over ftp, and we wouldn't want to delete anything
  533.   ;; important.
  534.   (save-excursion
  535.     (if (looking-at "^  \\(list \\)?wildcard ")
  536.     (forward-line 1))
  537.     ;; This is really aggressive. Too aggressive?
  538.     (let ((start (point)))
  539.       (skip-chars-forward " \t\n")
  540.       (if (looking-at efs-vms-filename-regexp)
  541.       (beginning-of-line)
  542.     (forward-line 1)
  543.     (skip-chars-forward " \t\n")
  544.     (beginning-of-line))
  545.       (delete-region start (point)))
  546.     (insert " \n"))
  547.   (efs-real-dired-insert-headerline dir))
  548.  
  549. (efs-defun efs-dired-fixup-listing vms (file path &optional switches wildcard)
  550.   ;; Some vms machines list the entire path. Scrape this off.
  551.   (setq path (efs-fix-path
  552.           'vms
  553.           ;; Need the file-name-directory, in case of widcards.
  554.           ;; Note that path is a `local' path rel. the remote host.
  555.           ;; Lose on wildcards in parent dirs. Fix if somebody complains.
  556.           (let (file-name-handler-alist)
  557.         (file-name-directory path))))
  558.   ;; Some machines put a Node name down too.
  559.   (let ((regexp (concat "^\\([_A-Za-z0-9][-_A-Za-z0-9]*\\$\\)?"
  560.             (regexp-quote path))))
  561.     (goto-char (point-min))
  562.     (while (re-search-forward regexp nil t)
  563.       (delete-region (match-beginning 0) (match-end 0))))
  564.   ;; Now need to deal with continuation lines.
  565.   (goto-char (point-min))
  566.   (let (col start end)
  567.     (while (re-search-forward
  568.         ";[0-9]+[ \t]*\\(\n[ \t]+\\)[^; \t\n]+[^\n;]*\n" nil t)
  569.       (setq start (match-beginning 1)
  570.         end (match-end 1))
  571.     ;; guess at the column dimensions
  572.       (or col
  573.       (save-excursion
  574.         (goto-char (point-min))
  575.         (if (re-search-forward
  576.          (concat efs-vms-filename-regexp
  577.              "[ \t]+[^ \t\n\r]") nil t)
  578.         (setq col (- (goto-char (match-end 0))
  579.                  (progn (beginning-of-line) (point))
  580.                  1))
  581.           (setq col 0))))
  582.       ;; join cont. lines.
  583.       (delete-region start end)
  584.       (goto-char start)
  585.       (insert-char ?   (max (- col (current-column)) 2))))
  586.   ;; Some vms dir listings put a triple null line before the total line.
  587.   (goto-char (point-min))
  588.   (skip-chars-forward "\n")
  589.   (if (search-forward "\n\n\n" nil t)
  590.       (delete-char -1)))
  591.  
  592. (efs-defun efs-dired-manual-move-to-filename vms
  593.   (&optional raise-error bol eol)
  594.   ;; In dired, move to first char of filename on this line.
  595.   ;; Returns position (point) or nil if no filename on this line.
  596.   ;; This is the VMS version.
  597.   (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point))))
  598.   (let (case-fold-search)
  599.     (if bol
  600.     (goto-char bol)
  601.       (skip-chars-backward "^\n\r"))
  602.     (if (re-search-forward efs-vms-filename-regexp eol t)
  603.     (goto-char (match-beginning 0))
  604.       (and raise-error (error "No file on this line")))))
  605.  
  606. (efs-defun efs-dired-manual-move-to-end-of-filename vms
  607.   (&optional no-error bol eol)
  608.   ;; Assumes point is at beginning of filename.
  609.   ;; So, it should be called only after (dired-move-to-filename t).
  610.   ;; case-fold-search must be nil, at least for VMS.
  611.   ;; On failure, signals an error or returns nil.
  612.   ;; This is the VMS version.
  613.   (let ((opoint (point)))
  614.     (and selective-display
  615.      (null no-error)
  616.      (eq (char-after
  617.           (1- (or bol (save-excursion
  618.                 (skip-chars-backward "^\r\n")
  619.                 (point)))))
  620.          ?\r)
  621.      ;; File is hidden or omitted.
  622.      (cond
  623.       ((dired-subdir-hidden-p (dired-current-directory))
  624.        (error
  625.         (substitute-command-keys
  626.          "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
  627.       ((error
  628.         (substitute-command-keys
  629.          "File line is omitted. Type \\[dired-omit-toggle] to un-omit."
  630.          )))))
  631.     (skip-chars-forward "-_A-Za-z0-9$.;")
  632.     (if (or (= opoint (point)) (not (memq (following-char) '(?\  ?\t ?\n ?\r))))
  633.     (if no-error
  634.         nil
  635.         (error "No file on this line"))
  636.       (point))))
  637.  
  638. (efs-defun efs-dired-ls-trim vms ()
  639.   (goto-char (point-min))
  640.   (let ((case-fold-search nil))
  641.     (re-search-forward  efs-vms-filename-regexp))
  642.   (beginning-of-line)
  643.   (delete-region (point-min) (point))
  644.   (forward-line 1)
  645.   (delete-region (point) (point-max)))
  646.  
  647. (efs-defun efs-internal-file-name-sans-versions vms
  648.   (name &optional keep-backup-version)
  649.   (efs-save-match-data
  650.     (if (string-match ";[0-9]+$" name)
  651.     (substring name 0 (match-beginning 0))
  652.       name)))
  653.  
  654. (efs-defun efs-dired-collect-file-versions vms ()
  655.   ;; If it looks like file FN has versions, return a list of the versions.
  656.   ;; That is a list of strings which are file names.
  657.   ;; The caller may want to flag some of these files for deletion.
  658.   (let ((completion-ignore-case (memq 'vms efs-case-insensitive-host-types))
  659.     result)
  660.     (dired-map-dired-file-lines
  661.      (function
  662.       (lambda (fn)
  663.     (if (string-match ";[0-9]+$" fn)
  664.         (let* ((base-fn (substring fn 0 (match-beginning 0)))
  665.            (base-version (file-name-nondirectory
  666.                   (substring fn 0 (1+ (match-beginning 0)))))
  667.            (bv-length (length base-version))
  668.            (possibilities (and
  669.                    (null (assoc base-fn result))
  670.                    (file-name-all-completions
  671.                     base-version
  672.                     (file-name-directory fn)))))
  673.           (if possibilities
  674.           (setq result
  675.             (cons (cons base-fn
  676.                     ;; code this explicitly
  677.                     ;; using backup-extract-version has a
  678.                     ;; lot of function-call overhead.
  679.                     (mapcar (function
  680.                          (lambda (fn)
  681.                            (string-to-int
  682.                         (substring fn bv-length))))
  683.                         possibilities)) result))))))))
  684.     result))
  685.  
  686. (efs-defun efs-dired-flag-backup-files vms (&optional unflag-p)
  687.   (interactive "P")
  688.   (let ((dired-kept-versions 1)
  689.     (kept-old-versions 0)
  690.     marker msg)
  691.     (if unflag-p
  692.     (setq marker ?\040 msg "Unflagging old versions")
  693.       (setq marker dired-del-marker msg "Purging old versions"))
  694.     (dired-clean-directory 1 marker msg)))
  695.  
  696. (efs-defun efs-internal-diff-latest-backup-file vms (fn)
  697.   ;; For FILE;#, returns the filename FILE;N, where N
  698.   ;; is the largest number less than #, for which this file exists.
  699.   ;; Returns nil if none found.
  700.   (efs-save-match-data
  701.     (and (string-match ";[0-9]+$" fn)
  702.      (let ((base (substring fn 0 (1+ (match-beginning 0))))
  703.            (num (1- (string-to-int (substring fn
  704.                           (1+ (match-beginning 0))))))
  705.            found file)
  706.        (while (and (setq found (> num 0))
  707.                (not (file-exists-p
  708.                  (setq file
  709.                    (concat base (int-to-string num))))))
  710.          (setq num (1- num)))
  711.        (and found file)))))
  712.  
  713. ;;;;--------------------------------------------------------------
  714. ;;;; Support for VMS DIR/FULL listings. (listing type vms:full)
  715. ;;;;--------------------------------------------------------------
  716.  
  717. (efs-defun efs-parse-listing vms:full
  718.   (host user dir path &optional switches)
  719.   ;; Parse the current buffer which is assumed to be a VMS FTP dir
  720.   ;; format, and return a hashtable as the result. SWITCHES are never used,
  721.   ;; but they must be specified in the argument list for compatibility
  722.   ;; with the unix version of this function.
  723.   ;; HOST = remote host name
  724.   ;; USER = user name
  725.   ;; DIR = directory in as a full remote path
  726.   ;; PATH = directory in full efs path syntax
  727.   ;; SWITCHES = ls switches (not relevant here)
  728.   (goto-char (point-min))
  729.   (efs-save-match-data
  730.     (efs-parse-vms-listing)))
  731.  
  732. ;;; Tree Dired
  733.  
  734. (or (assq 'vms:full efs-dired-re-exe-alist)
  735.     (setq efs-dired-re-exe-alist
  736.       (cons (cons 'vms:full efs-dired-vms-re-exe)
  737.         efs-dired-re-exe-alist)))
  738.  
  739. (or (assq 'vms:full efs-dired-re-dir-alist)
  740.     (setq efs-dired-re-dir-alist
  741.       (cons (cons 'vms:full efs-dired-vms-re-dir)
  742.         efs-dired-re-dir-alist)))
  743.  
  744. (efs-defun efs-dired-insert-headerline vms:full (dir)
  745.   ;; Insert a blank line for aesthetics.
  746.   (insert " \n")
  747.   (forward-char -2)
  748.   (efs-real-dired-insert-headerline dir))
  749.  
  750. (efs-defun efs-dired-manual-move-to-filename vms:full
  751.   (&optional raise-error bol eol)
  752.   (let ((efs-dired-listing-type 'vms))
  753.     (efs-dired-manual-move-to-filename raise-error bol eol)))
  754.  
  755. (efs-defun efs-dired-manual-move-to-end-of-filename vms:full
  756.   (&optional no-error bol eol)
  757.   (let ((efs-dired-listing-type 'vms))
  758.     (efs-dired-manual-move-to-end-of-filename no-error bol eol)))
  759.  
  760. ;;; end of efs-vms.el
  761.